Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue47/System/Main.pas

Pascal/Delphi Source File | 1999-06-03 | 6.3 KB | 225 lines

unit Main;

interface

uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    StdCtrls, ComCtrls, ExtCtrls;

const
    // Magic signatures
    D2Magic  =         $50505348;
    D3Magic  =         $44518641;
    D4Magic  =         $4768A6D8;
    B3Magic  =         $475896C8;

    // DCU record tags
    Tag_End           =        $61;
    Tag_DFK_Source    =        $70;
    Tag_DFK_Object    =           $71;
    Tag_DFK_Resource  =           $72;
    Tag_DFK_TheAdr    =           $73;

type
    TForm1 = class(TForm)
    Scan: TButton;
    StatusBar1: TStatusBar;
    TreeList: TListView;
    procedure ScanClick(Sender: TObject);
    procedure TreeListDblClick(Sender: TObject);
    private
    { Private declarations }
        Scanning: Boolean;
        procedure ScanDrive (const Path: String);
        procedure FoundOne (const PathName: String);
        function  DCUReadString (var p: PChar): String;
        procedure DCUDumpDFKRecord (const Typ: String; var p: PChar);
        function  DCUDecodeNum (var p: PChar): Integer;
    public
      { Public declarations }
    end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ScanClick (Sender: TObject);
var
    p: PChar;
    szBuff: array [0..255] of Char;
begin
    Scanning := not Scanning;
    if Scanning then begin
        Scan.Caption := 'Stop Scan!';
        Screen.Cursor := crHourGlass;
        TreeList.Items.Clear;
        TreeList.Items.BeginUpdate;

        try
            p := szBuff;
            GetLogicalDriveStrings (sizeof (szBuff), szBuff);
            while Scanning and (p^ <> #0) do begin
                if GetDriveType (p) = Drive_Fixed then ScanDrive (p);
                Inc (p, 4);
            end;
        finally
            Scanning := False;
            Scan.Caption := 'Scan!';
            Screen.Cursor := crDefault;
            TreeList.Items.EndUpdate;
        end;
    end;
end;

procedure TForm1.FoundOne (const PathName: String);
var
    eof: Byte;
    S: String;
    Valid: Boolean;
    fs: TFileStream;
    Item: TListItem;
    Magic: array [0..3] of LongInt;
begin
    fs := TFileStream.Create (PathName, fmOpenRead);
    try
        fs.Read (Magic, sizeof (Magic));
        fs.Position := fs.Size - 1;
        fs.Read (eof, sizeof (eof));
        Valid := (Magic [1] = fs.Size) and (eof = Tag_End);
        if (Magic [0] = D2Magic) and ((Magic [3] and $ff) <> 0) then begin
            ShowMessage (PathName + ' is invalid Delphi2 DCU.  Skipping...');
            Valid := False;
        end;
    finally
        fs.Free;
    end;

    if Valid then begin
        Item := TreeList.Items.Add;
        Item.Caption := PathName;
        case Magic [0] of
            D2Magic:   S := 'Delphi 2';
            D3Magic:   S := 'Delphi 3';
            D4Magic:   S := 'Delphi 4';
            B3Magic:   S := 'C++ Builder 3';
            else       S := '???' + IntToHex (Magic [0], 8);
        end;
        Item.SubItems.Add (S);

        if Magic [2] = $ffffffff then S := 'Invalid date/time' else
        S := FormatDateTime ('dddd, mmmm d, yyyy, hh:mm AM/PM', FileDateToDateTime (Magic [2]));
        Item.SubItems.Add (S);
    end;
end;

procedure TForm1.ScanDrive (const Path: String);
var
    Res: Integer;
    SR: TSearchRec;
begin
    Application.ProcessMessages;
    StatusBar1.Panels [0].Text := 'Scanning ' + Path;
    Res := FindFirst (Path + '*.*', faAnyFile, SR);
    try
        while Scanning and (Res = 0) do begin
            if SR.Name [1] <> '.' then begin
                if UpperCase (ExtractFileExt (SR.Name)) = '.DCU' then FoundOne (Path + SR.Name) else
                if ((SR.Attr and faDirectory) <> 0) then ScanDrive (Path + SR.Name + '\');
            end;
            Res := FindNext (SR);
        end;
    finally
        FindClose (SR);
    end;
end;

function TForm1.DCUReadString (var p: PChar): String;
var
    Len: Byte;
begin
    Result := '';
    Len := Ord (p^);  Inc (p);
    while Len <> 0 do begin
        Result := Result + p^;
        Inc (p);  Dec (Len);
    end;
end;

function  TForm1.DCUDecodeNum (var p: PChar): Integer;
const
    SizeNum: array [0..15] of Byte = ( 1, 2, 1, 3, 1, 2, 1, 4, 1, 2, 1, 3, 1, 2, 1, 5 );
    ShiftNum: array [0..15] of Byte = ( 25, 18, 25, 11, 25, 18, 25, 4, 25, 18, 25, 11, 25, 18, 25, 0 );
var
    Idx: Byte;
begin
    Idx := Ord (p^) and 15;
    Inc (p, SizeNum [Idx]);
    Result := PLongInt (p - 4)^ shr ShiftNum [Idx];
end;

procedure TForm1.DCUDumpDFKRecord (const Typ: String; var p: PChar);
var
    s: String;
    modtime: LongInt;
begin
    s := Typ + ' = ' + DCUReadString (p) + #10;
    try
        modtime := PLongInt (p)^;  Inc (p, 4);
        s := s + 'ModTime = ' + FormatDateTime ('dddd, mmmm d, yyyy, hh:mm AM/PM', FileDateToDateTime (modtime)) + #10;
    except
        { Eat exceptions if modtime is invalid } ;
    end;

    s := s + 'File index = ' + IntToStr (DCUDecodeNum (p));
    ShowMessage (s);
end;

procedure TForm1.TreeListDblClick(Sender: TObject);
var
    Tag: Byte;
    Buff, p: PChar;
    Item: TListItem;
    fs: TFileStream;
begin
    Item := TreeList.Selected;
    if Item = Nil then Exit;
    fs := TFileStream.Create (Item.Caption, fmOpenRead);
    try
       GetMem (Buff, fs.Size);
       fs.Read (Buff^, fs.Size);
    finally
       fs.Free;
    end;

    // point at first byte of interest in DCU image
    p := Buff + 12;
    // Skip over Delphi 2's always-zero string
    if PLongInt(Buff)^ = D2Magic then Inc (p);

    try
        while True do begin
            Tag := Ord (p^);  Inc (p);
            case Tag of
                Tag_End:           Exit;  // All done!
                Tag_DFK_Source:    DCUDumpDFKRecord ('Source File', p);
                Tag_DFK_Object:    DCUDumpDFKRecord ('Object File', p);
                Tag_DFK_Resource:  DCUDumpDFKRecord ('Resource File', p);
                Tag_DFK_TheAdr:    DCUDumpDFKRecord ('Tag_DFK_TheAdr ????', p);
                else               begin
                                       ShowMessage (Format ('Unknown tag $%x', [Tag]));
                                       Exit;
                                   end;
            end;
        end;
    finally
        FreeMem (Buff);
    end;
end;

end.